home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1995 #5 & #6 / Amiga Plus CD - 1995 - No. 5 and 6.iso / pd / serien / purity / nr.13 / kickpascal-programme / amigapascal / amigapascal.p < prev    next >
Text File  |  1995-04-22  |  9KB  |  476 lines
  1. PROGRAM Amiga_Pascal_Compiler;
  2.  
  3. CONST programm  =  0;
  4.       variable  =  1;
  5.       beginn    =  2;
  6.       ende      =  3;
  7.       whiled    =  4;
  8.       dow       =  5;
  9.       print     =  6;
  10.       comma     =  7;
  11.       equal     =  8;
  12.       plus      =  9;
  13.       minus     = 10;
  14.       identi    = 11;
  15.       konstante = 12;
  16.       eofi      = 13;
  17.       cr        = 14;
  18.       mulu      = 15;
  19.       divu      = 16;
  20.       maxidlen  = 79;
  21.       version   = "$VER: Amiga-Pascal-Compiler 1.0 (18.02.93)";
  22.  
  23. TYPE Identifier = STRING[maxIDlen+1];
  24.  
  25. VAR source,destination   : FILE OF CHAR;
  26.     chara    : CHAR;
  27.     sym      : BYTE;
  28.     ident    : Identifier;
  29.     constant : LONGINT;
  30.     labels   : INTEGER;
  31.     zeile,e  : INTEGER;
  32.     errtxt,fname,fname2,extx  : STRING[50];
  33.     c        : CHAR;
  34.  
  35. PROCEDURE GetChar(VAR chara: CHAR);
  36.  
  37. BEGIN
  38.   READ(source,chara);
  39.   IF chara=CHR(10) THEN INC(Zeile);
  40. END;
  41.  
  42. PROCEDURE GetSym(VAR sym: BYTE);
  43.  
  44. VAR i: INTEGER;
  45.  
  46. BEGIN
  47.   GetChar(chara);
  48.   WHILE chara IN [0..9,11..32] DO GetChar(chara);
  49.   ident:="";
  50.   CASE chara OF
  51.     CHR(10): sym:=cr;
  52.     'a'..'z',
  53.     'A'..'Z': BEGIN
  54.                 i:=1;
  55.                 WHILE (i<=maxIDlen) AND (UPCASE(chara)>='A') AND (UPCASE(chara)<='Z') DO
  56.                 BEGIN
  57.                   ident:=ident+chara;
  58.                   GetChar(chara);
  59.                   INC(i);
  60.                 END;
  61.                 IF ident = "PROGRAM"      THEN sym:=programm
  62.                 ELSE IF ident = "VAR"     THEN sym:=variable
  63.                 ELSE IF ident = "BEGIN"   THEN sym:=beginn
  64.                 ELSE IF ident = "END"     THEN sym:=ende
  65.                 ELSE IF ident = "WHILE"   THEN sym:=whiled
  66.                 ELSE IF ident = "DO"      THEN sym:=dow
  67.                 ELSE IF ident = "WRITELN" THEN sym:=print
  68.                 ELSE                           sym:=identi;
  69.               END;
  70.     '0'..'9': BEGIN
  71.                 constant:=0;
  72.                 WHILE chara IN ['0'..'9'] DO
  73.                 BEGIN
  74.                   constant:=10*constant+ORD(chara)-ORD('0');
  75.                   GetChar(chara);
  76.                 END;
  77.                 sym:=konstante;
  78.               END;
  79.     ':': BEGIN
  80.            GetChar(chara);
  81.            IF chara="=" THEN sym:=equal;
  82.          END;
  83.     ',': sym:=comma;
  84.     '+': sym:=plus
  85.     '-': sym:=minus;
  86.     '*': sym:=mulu;
  87.     '/': sym:=divu;
  88.     OTHERWISE BEGIN
  89.                 errtxt:='Unexpected symbol in line '+INTSTR(zeile);
  90.                 ERROR(errtxt);
  91.               END;
  92.   END;
  93. END;
  94.  
  95. PROCEDURE W(s: STR);
  96.  
  97. BEGIN
  98.   WRITE(destination,s);
  99. END;
  100.  
  101. PROCEDURE WL(s: STR);
  102.  
  103. BEGIN
  104.   WRITELN(destination,s);
  105. END;
  106.  
  107. PROCEDURE DCL(vari: STR);
  108.  
  109. BEGIN
  110.   W(vari);
  111.   WL(": dc.l 0");
  112. END;
  113.  
  114. PROCEDURE MOVEvarD0(vari: STR);
  115.  
  116. BEGIN
  117.   W("    MOVE.L  ");
  118.   W(vari);
  119.   WL(",D0");
  120. END;
  121.  
  122. PROCEDURE MOVEconstD0(c: LONGINT);
  123.  
  124. VAR numm: STRING[5];
  125.  
  126. BEGIN
  127.   W("    MOVE.L  #");
  128.   numm:=INTSTR(c);
  129.   W(numm);
  130.   WL(",D0");
  131. END;
  132.  
  133. PROCEDURE MOVED0var(name: PTR);
  134.  
  135. BEGIN
  136.   W("    MOVE.L  D0,");
  137.   WL(name);
  138. END;
  139.  
  140. PROCEDURE MOVED1var(name: PTR);
  141.  
  142. BEGIN
  143.   W("    MOVE.L  D1,");
  144.   WL(name);
  145. END;
  146.  
  147. PROCEDURE MOVED0D1;
  148.  
  149. BEGIN
  150.   WL("    MOVE.L  D0,D1");
  151. END;
  152.  
  153. PROCEDURE ADDD1D0;
  154.  
  155. BEGIN
  156.   WL("    ADD.L   D1,D0");
  157. END;
  158.  
  159. PROCEDURE MULSD1D0;
  160.  
  161. BEGIN
  162.   WL("    MULS.L  D1,D0");
  163. END;
  164.  
  165. PROCEDURE DIVSD1D0;
  166.  
  167. BEGIN
  168.   WL("    DIVS.L  D0,D1");
  169. END;
  170.  
  171. PROCEDURE NEGD0;
  172.  
  173. BEGIN
  174.   WL("    NEG.L   D0");
  175. END;
  176.  
  177. PROCEDURE TSTD0;
  178.  
  179. BEGIN
  180.   WL("    TST.L   D0");
  181. END;
  182.  
  183. FUNCTION GetLabel(VAR labels: INTEGER): INTEGER;
  184.  
  185. BEGIN
  186.   INC(labels);
  187.   GetLabel:=labels;
  188. END;
  189.  
  190. PROCEDURE mlabel(l: INTEGER);
  191.  
  192. VAR numm: STRING[5];
  193.  
  194. BEGIN
  195.   W("L");
  196.   numm:=INTSTR(l);
  197.   W(numm);
  198.   WL(":");
  199. END;
  200.  
  201. PROCEDURE Ble(l: INTEGER);
  202.  
  203. VAR numm: STRING[5];
  204.  
  205. BEGIN
  206.   W("    BLE     L");
  207.   numm:=INTSTR(l);
  208.   WL(numm);
  209. END;
  210.  
  211. PROCEDURE BRA(l: INTEGER);
  212.  
  213. VAR numm: STRING[5];
  214.  
  215. BEGIN
  216.   W("    BRA     L");
  217.   numm:=INTSTR(l);
  218.   WL(numm);
  219. END;
  220.  
  221. PROCEDURE PrintD0;
  222.  
  223. BEGIN
  224.   WL("    LEA     _format,A0");
  225.   WL("    MOVE.L  A0,D1"     );
  226.   WL("    LEA     _print,A0" );
  227.   WL("    MOVE.L  A0,D2"     );
  228.   WL("    MOVE.L  D0,(A0)"   );
  229.   WL("    MOVE.L  _dos,A6"   );
  230.   WL("    JSR     -954(A6)"  );
  231. END;
  232.  
  233. PROCEDURE StartUp(Start: INTEGER);
  234.  
  235. BEGIN
  236.   WL("_dos:       DC.L   0"              );
  237.   WL("_dosname:   DC.B   'dos.library',0");
  238.   WL("_format:    DC.B   '%ld',10,0"     );
  239.   WL("            DS.L   0"              );
  240.   WL("_print:     DC.L   0"              );
  241.   mlabel(start);
  242.   WL("    LEA      _dosname,A1"          );
  243.   WL("    MOVE.L   #37,D0"               );
  244.   WL("    MOVE.L   $4,A6"                );
  245.   WL("    JSR      -552(A6)"             );
  246.   WL("    TST.L    D0"                   );
  247.   WL("    BNE.S    ok_"                  );
  248.   WL("    RTS"                           );
  249.   WL("ok_:"                              );
  250.   WL("    MOVE.L   D0,_dos"              );
  251. END;
  252.  
  253. PROCEDURE CleanUp;
  254.  
  255. BEGIN
  256.   WL("    MOVE.L   _dos,A1" );
  257.   WL("    MOVE.L   $4,A6"   );
  258.   WL("    JSR      -414(A6)");
  259.   WL("    MOVE.L   #0,D0"   );
  260.   WL("    RTS"              );
  261.   WL("    END"              );
  262. END;
  263.  
  264. {Parser;}
  265.  
  266. PROCEDURE Check(symm: BYTE; msg: STR);
  267.  
  268. BEGIN
  269.   IF sym=symm THEN GetSym(Sym)
  270.               ELSE
  271.               BEGIN
  272.                 errtxt:=msg+" IN ZEILE "+INTSTR(zeile);
  273.                 ERROR(errtxt);
  274.               END;
  275. END;
  276.  
  277. PROCEDURE VarDeclaration;
  278.  
  279. BEGIN
  280.   GetSym(sym);
  281.   WHILE sym=identi DO
  282.   BEGIN
  283.     IF sym<>identi THEN
  284.     BEGIN
  285.       errtxt:='Identifier expected in line '+INTSTR(zeile)+'!';
  286.       ERROR(errtxt);
  287.     END;
  288.     DCL(Ident);
  289.     GetSym(Sym);
  290.   END;
  291.   GetSym(Sym);
  292. END;
  293.  
  294. PROCEDURE Factor;
  295.  
  296. BEGIN
  297.   CASE Sym OF
  298.     identi: BEGIN
  299.               MOVEvarD0(ident);
  300.               GetSym(Sym);
  301.             END;
  302.     konstante: BEGIN
  303.                  MOVEconstD0(constant);
  304.                  GetSym(sym);
  305.                END;
  306.     OTHERWISE BEGIN
  307.                 errtxt:='Factor expected in line '+INTSTR(zeile)+'!';
  308.                 ERROR(errtxt);
  309.               END;
  310.   END;
  311. END;
  312.  
  313. FUNCTION Expression: BOOLEAN;
  314.  
  315. VAR neg,flag: BOOLEAN;
  316.  
  317. BEGIN
  318.   flag:=FALSE;
  319.   neg:=FALSE;
  320.   IF sym IN [plus,minus] THEN neg:=sym=minus;
  321.   Factor;
  322.   IF neg THEN NEGD0;
  323.   WHILE sym IN [plus,minus] DO
  324.   BEGIN
  325.     neg:=sym=minus;
  326.     GetSym(Sym);
  327.     MOVED0D1;
  328.     Factor;
  329.     IF neg THEN NEGD0;
  330.     ADDD1D0;
  331.   END;
  332.   WHILE sym=mulu DO
  333.   BEGIN
  334.     GetSym(sym);
  335.     MOVED0D1;
  336.     Factor;
  337.     MULSD1D0;
  338.   END;
  339.   WHILE sym=divu DO
  340.   BEGIN
  341.     flag:=TRUE;
  342.     GetSym(sym);
  343.     MOVED0D1;
  344.     Factor;
  345.     DIVSD1D0;
  346.   END;
  347.   Expression:=flag
  348. END;
  349.  
  350. PROCEDURE Statement;
  351.  
  352. VAR start,ent: INTEGER;
  353.     varname  : STRING[maxIDlen];
  354.     boob     : BOOLEAN;
  355.  
  356. BEGIN
  357.   CASE sym OF
  358.     identi: BEGIN
  359.               varname:=ident;
  360.               GetSym(sym);
  361.               Check(equal,"':=' expected!");
  362.               IF Expression THEN MOVED1Var(^varname)
  363.                             ELSE MOVED0var(^varname);
  364.             END;
  365.     whiled: BEGIN
  366.               GetSym(sym);
  367.               start:=GetLabel(labels);
  368.               ent:=GetLabel(labels);
  369.               mlabel(start);
  370.               boob:=Expression;
  371.               Check(dow,"DO expected!");
  372.               TSTD0;
  373.               BLE(ent);
  374.               Check(beginn,"BEGIN expected!");
  375.               WHILE sym<>ende DO Statement;
  376.               BRA(start);
  377.               mlabel(ent);
  378.             END;
  379.     print: BEGIN
  380.              GetSym(sym);
  381.              boob:=Expression;
  382.              PrintD0;
  383.            END;
  384.     OTHERWISE BEGIN
  385.                 errtxt:="Statement expected in line "+INTSTR(zeile)+'!';
  386.                 ERROR(errtxt);
  387.               END;
  388.   END;
  389. END;
  390.  
  391. PROCEDURE Programkopf;
  392.  
  393. VAR start: INTEGER;
  394.  
  395. BEGIN
  396.   GetSym(sym);
  397.   Check(programm,"PROGRAM expected!");
  398.   Check(identi,"Name expected");
  399.   start:=GetLabel(labels);
  400.   BRA(start);
  401.   GetSym(sym);
  402.   IF sym=variable THEN VarDeclaration;
  403.   Check(beginn,"BEGIN expected!");
  404.   StartUp(start);
  405.   WHILE sym<>ende DO Statement;
  406.   CleanUp;
  407.   Check(ende,"END expected!");
  408. END;
  409.  
  410. FUNCTION GetName: STR;
  411.  
  412. VAR s  : STRING[80];
  413.     i,j: INTEGER;
  414.     name: STRING[80];
  415.  
  416. BEGIN
  417.   IF parameterlen>=80 THEN
  418.     Name:=''
  419.   ELSE
  420.   BEGIN
  421.     s:=parameterstr;
  422.     s[parameterlen+1]:=CHR(0);
  423.     i:=1;
  424.     WHILE (s[i]=' ') DO INC(i);
  425.     j:=1;
  426.     WHILE s[i]>' ' DO
  427.     BEGIN
  428.       name[j]:=s[i];
  429.       INC(i);
  430.       INC(j)
  431.     END;
  432.     name[j]:=CHR(0)
  433.   END;
  434.   GetName:=name;
  435. END;
  436.  
  437. BEGIN
  438.   IF NOT FromWB THEN
  439.   BEGIN
  440.     labels:=0;
  441.     Zeile:=1;
  442.     fname:=GetName;
  443.     IF (fname<>"") AND (fname<>"?") THEN
  444.     BEGIN
  445.       RESET(source,fname);
  446.       IF ioResult=0 THEN
  447.       BEGIN
  448.         fname2:=fname+".s";
  449.         REWRITE(destination,fname2);
  450.         IF ioResult=0 THEN
  451.         BEGIN
  452.           WRITE('Compiling...');
  453.           ProgramKopf;
  454.           ParameterLen:=0;
  455.           CLOSE(destination);
  456.           CLOSE(source);
  457.           WRITELN('Finished.');
  458.           WRITELN('Please compile with a68k and link it with BLink');
  459.           WRITELN('Please type: '\e'32ma68k ',fname,'.s');
  460.           WRITELN('             blink ',fname,'.o TO ',fname,'.exe'\e'31m');
  461.         END
  462.         ELSE WRITELN("Couldn't open output file! (",fname2,")");
  463.       END
  464.       ELSE WRITELN("Couldn't open input file! (",fname,")");
  465.     END
  466.     ELSE
  467.     BEGIN
  468.       WRITELN(""\e"32mAmiga-Pascal-Compiler 1.0"\e"31m by Danny Amor (18.02.93)");
  469.       WRITELN("Written in Kick-"\e"32mPascal"\e"31m 2.12");
  470.       WRITELN("For further information read the doc-file");
  471.       WRITELN("Usage: Compile <source file>");
  472.     END;
  473.   END;
  474. END;
  475.  
  476.